perm filename SCANR.F4[1,MUS] blob
sn#065169 filedate 1973-10-02 generic text, type T, neo UTF8
00010 C SUBRS. SCANR, NALF, EDIT
00020
00100 C ***** MSS SCANNER *************************
00200 SUBROUTINE SCANR
00300 DIMENSION IQ(10),LRUD(4)
00400 COMMON/ALF/INP(72),ML
00500 COMMON /SC/J,L,MK
00600 1 ,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JN,DBST,NFLG,IXX,ISEMI,QQ
00700 1 ,VX(50),IAMP,K,KN,M,MODE,IBLA
00800 EQUIVALENCE (IQ(1),VX(41)),(VX1,VX(1)),(VX2,VX(2))
00810 DATA IBLA/' '/,LRUD/'L','R','U','D'/
01000 C FOR LEFT, RIGHT, UP, DOWN, EDIT
01100 NNUM=-1
01200 ISKP=0
01300 JJ=0
01400 XMINUS=1.
01500 C LEAVES BLANK WHEN REST.
01600 999 IDECI=-1
01700 M=0
01800 2799 N=INP(ML)
01900 899 ML=ML+1
01910 781 IF(N.EQ.'/')N=ISEMI
01955 C FOR MOTIVIC TRANFORMATIONS
02000 IF(N.EQ.ISEMI.OR.N.EQ.'*')GO TO 751
02050 C '*' AND '/' ADDED ABOVE 4/18/73
02100 IF(N.NE.IBLA.AND.N.NE.',')GO TO 510
02200 4702 IF(ISKP)202,2799,2799
02300 512 ML=ML+1
02400 IF(INP(ML).EQ.ISEMI)RETURN
02500 GO TO 512
02600
02700 510 IF(JN.GE.0)GO TO 173
02710 C SKIP(JN=+1) IF NOT COMING FROM 'EDIT'
02800 JN=1
02900 DO 702 K=1,4
03000 702 IF(N.EQ.LRUD(K))GO TO 703
03100 C FINDS L, R, U, D
03200 C YOU CAN TYPE THE FULL WORD
03300 703 JJ=JJ+1
03400 IF(K.EQ.4.AND.INP(ML).EQ.'E')K=99
03500 C 'DE'=DELETE
03600 IF(N.EQ.'E')K=55
03650 C 'E'= EDIT
03675 IF(N.EQ.'C')K=2222
03687 IF(N.EQ.'X')K=222
03693 C 'C'=COPY, 'X'=EXIT FROM EDIT MODE
03700 VX(JJ)=K
03800 704 IF(INP(ML).EQ.IBLA.OR.INP(ML).EQ.',')GO TO 2799
03850 C PUT COMMA ERASER IN SCX.
03900 ML=ML+1
04000 C SO IT WILL SKIP 'D' AND 'EL' IN 'EDIT' AND 'DEL'
04100 GO TO 704
04110 17 IF(N.NE.'+')GO TO 172
04120 NOLD=NOLD+6
04130 GO TO 7410
04140 172 IF(N.NE.'-')GO TO 173
04150 NOLD=NOLD-6
04160 C FOR + OF - IN PROXIMITY MODE.
04170 GO TO 7410
04200 173 K=NALF(N)
04300 IF(N.GT.0)GO TO 1410
04400 C JUMP IF NOT A LETTER
04500 QQ=0
04600 IF(K.LT.8)GO TO 15
04700 C JUMP IF A POSSIBLE NOTE
04800 IF(K.NE.11)GO TO 16
04900 C JUMP IF NOT A KSIG
05000 18 N=INP(ML)
05100 ML=ML+1
05200 IF(N.EQ.IBLA.OR.N.EQ.'S'.OR.N.EQ.'+')GO TO 18
05300 IF(N.EQ.ISEMI)GO TO 20
05400 IF(N.NE.'-'.AND.N.NE.'F')GO TO 19
05500 QQ=-10000.
05600 GO TO 18
05700 19 A=NALF(N)
05800 GO TO 18
05900 20 VX(1)=-A*1000.-99.+QQ
06000 C -4099=4 SHARPS, -14099=4 FLATS, ETC.
06100 RETURN
06200 16 IF(K.NE.9)GO TO 2
06300 VX(1)=22.
06400 C FOR EDIT I21 ETC.
06500 GO TO 2799
06600 2 IF(K.NE.13)GO TO 3
06700 C JUMP IF NOT A MEASURE LINE
06800 VX(1)=-599.
06850 K=NALF(INP(ML))
06860 IF(K.GT.0.AND.K.LE.9)VX(1)=-599.-K
06870 C 'M2'= A BAR LINE UP 2 STAVES. ETC.
06900 GO TO 512
07000 3 IF(K.GT.16)GO TO 4
07100 C JUMP IF NOT FOR 'PROXIMITY' MODE
07200 NSWCH=K-15
07300 GO TO 2799
07400 C TO SWITCH ALWAYS USE OCT.# /PBF4/ /OE5/ P=PROXIMITY, O=ORDINARY
07500 4 IF(K.EQ.18)GO TO 73
07600 C JUMP IF A REST
07700 IF(K.EQ.24)GO TO 210
07800 C JUMP IF IT'S AN X
07900 IF(K.NE.20)GO TO 899
08000 C TRY AGAIN IF NOT A 'T'
08100 VX(1)=-199.
08200 IF(INP(ML).EQ.'E')VX(1)=-499.
08300 GO TO 512
08400 C NEXT IT'S A NOTE OR CLEF
08500 CC NFLG=-1
08600 15 NNUM=K-2
08700 IF(NNUM.LE.0)NNUM=NNUM+7
08800 N=INP(ML)
08900 IF(N.NE.'A')GO TO 5
09000 C JUMP IF NOT BASS CLEF
09100 VX(1)=-299.
09200 GO TO 512
09300 5 IF(N.NE.'L')GO TO 6
09400 C JUMP IF NOT ALTO CLEF
09500 VX(1)=-399.
09600 GO TO 512
09700 CC6 NNUM=K-2
09800 CC IF(NNUM.LE.0)NNUM=K+5
09900 6 K=1
10000 IF(NNUM.GT.3)K=2
10100 NNUM=NNUM+NNUM-K
10200 C FOUND A NOTE
10300
10400 K=NALF(N)
10500 IF(N.GT.0)GO TO 7
10600 C JUMP IF NOT A LETTER
10700 QQ=10000.
10800 IF(K.EQ.14)GO TO 610
10900 IF(K.EQ.19)GO TO 8
11000 C JUMP IF NATURAL
11100 QQ=100.
11200 NNUM=NNUM-1
11300 GO TO 610
11400 8 QQ=1000.
11500 NNUM=NNUM+1
11600 610 ML=ML+1
11700 K=NALF(INP(ML))
11800 7 IF(K.EQ.11.OR.K.LT.0)GO TO 5410
11900 C JUMP IF SEMICOLON OR BLANK
12000 JSCA=K-1
12100 ML=ML+1
12200 KN=0
12300 GO TO 2410
12400 5410 KN=-1
12500 6410 IF(NSWCH.EQ.0)GO TO 2410
12550 C K=-16 IS A BLANK??
12600 CC IF(K.LT.0.AND.K.NE.-16)NOLD=NOLD-6*(K+4)
12610 IF(K.NE.-3.AND.K.NE.-5)GO TO 7410
12620 NOLD=NOLD-6*(K+4)
12630 ML=ML+1
12700 C -=-3 +=-5 /B/B-/ JUMPS DOWN OCT., /B/B+/ UP OCT.
12800 7410 IF(NOLD-NNUM.GT.5.AND.JSCA.LT.7)JSCA=JSCA+1
12900 IF(NOLD-NNUM.LT.-5.AND.JSCA.GT.0)JSCA=JSCA-1
13000 C WILL JUMP TO NEAREST NOTE *********** MAY 22,71
13100 2410 JJ=1
13150 VX2=0
13200 VX1=(JSCA*12+NNUM+QQ)*DBST
13300 C DOUBLE STOPS ARE NEG. NUMBERS
13400 NOLD=NNUM
13500 4410 NNUM=-2
13600 IF(INP(ML).EQ.ISEMI)RETURN
13700 C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
13800 GO TO 310
13900 210 JJ=JJ+1
14000 IF(JJ.EQ.1)GO TO 3310
14100 XMINUS=1.
14200 VX(JJ)=0
14300 C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
14400 GO TO 310
14500
14600 CC1410 IF(N.LT.0)GO TO 781
14700 C JUMP IF A LETTER
14800 1410 IF(N.NE.'-')GO TO 14
14900 XMINUS=-1.
15000 GO TO 2799
15100 14 ISKP=-1
15200 IF(N.NE.'.')GO TO 79
15300 IDECI=M
15400 GO TO 75
15500 79 M=M+1
15600 IQ(M)=NALF(N)
16000
16100 75 IF(N.NE.ISEMI.AND.INP(ML).NE.1)GO TO 2799
16200 751 IF(ISKP.EQ.0)RETURN
16300 202 IF(IDECI.NE.-1)GO TO 302
16400 IDECI=0
16500 GO TO 402
16600 302 IDECI=M-IDECI
16700 402 KN=0
16800 IEXP=M-1
16900 IF(M.LT.1)M=1
17000 DO 171 K=1,M
17010 IF(IEXP.GT.1)GO TO 1
17020 KV=10
17030 IF(IEXP.EQ.0)KV=1
17040 GO TO 11
17100 1 KV=10**IEXP
17200 CC IF(IEXP.EQ.0)KV=1
17300 11 KN=KN+IQ(K)*KV
17400 171 IEXP=IEXP-1
17500 A=10**IDECI
17600 IF(IDECI.EQ.0)A=1.
17700 JJ=JJ+1
17800 VX(JJ)=KN/A*XMINUS
17900 JN=-JN
18000 C SETS IT TO -1 FOR L,R,U,D EDIT ROUTINE
18100 IF(MODE.NE.2)XMINUS=1.
18200 C************: MODE #?
18300 C ONLY ONE - NEEDED FOR RHY.COMPOSITE
18400 1310 IF(INP(ML).NE.1)GO TO 310
18500 VX(JJ+1)=VX(JJ)*2.
18600 JJ=JJ+1
18700 ML=ML+1
18800 GO TO 1310
18900 206 ML=ML+2
19000 3310 VX(1)=-99.
19100 310 ISKP=0
19200 IF(N.NE.ISEMI)GO TO 999
19300
19400 RETURN
19500 73 JJ=JJ+1
19600 IF(INP(ML).EQ.'E')GO TO 206
19700 C NEXT IS FOR A REST ('R')
19800 VX(JJ)=85.
19900 GO TO 4410
20000 END
20100
20200
20300
20400 FUNCTION NALF(I)
20500 J='A'
20600 M=-1
20700 IF(I.LT.0)GO TO 10
20800 J=' '
20900 C SEE FORTRAN MAN. FOR VALUES OF NON-NUMS.
21000 M=16
21100 C IF I IS '0', NALF WILL BE 0, 'A'=1
21200 10 NALF=(I-J)/536870912-M
21400 END
21500
21600
21700 SUBROUTINE EDIT(JJA,RJJB)
21800 COMMON/ALF/INP(72),ML
21900 COMMON /SC/JL,LJ,MK
22000 1 ,ISKP,XMINUS,N,IEXP,LK,NNUM,JM,JN,DBST,NFLG,IXX,ISEMI,QQ
22100 1 ,RVX(50),IAMP,A,KN,B,MODE,IBLA
22200 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
22300 COMMON/RRJJ/RJJ(20)
22500 EQUIVALENCE (RVX1,RVX(1)),(RVX2,RVX(2)),(RVX4,RVX(4))
22600 1,(RJJ2,RJJ(2)),(RVX3,RVX(3))
22700 JN=-1
22800 C THIS IS FLAG IN SCANR
22900 INP(20)=ISEMI
23000 ML=1
23100 RVX2=0
23200 RVX4=0
23250 C E=EDIT(55), C=COPY(2222), X=EXIT(222), DE=DEL(99), L=LTPN
23300 CALL SCANR
23400 JN=0
23450 RJB=RVX2
23500 IF(RVX1.LT.10.)GO TO 7
23600 JA=RVX1
23750 IF(JA.EQ.99)RJB=0
23800 IF(RJB.NE.0.OR.JA.NE.55)RETURN
24400 5 CALL LPEN(RJQ(1),RJB,K)
24500 C CURSOR WILL FIND HORIZ. POSITION FOR 55 EDIT.
24610 RVX1=2.
24620 RVX2=RJB-RJJB
24630 RVX3=3.
24730 RJQ(2)=0
24740 RJJ(1)=RJQ(1)
24752 C ↑↑↑↑↑↑↑↑↑↑↑↑?????????
24765 C SO JD WILL BE 0 IN MAIN PROG.
24782 GO TO 8
24800 C FOR EDIT MODE
24805 7 JA=0
24810 IF(RVX2.NE.0)GO TO 8
24812 IF(RVX1.NE.4)GO TO 5
24814 CC JA=99.
24816 RETURN
24820 C FOR LIGHT PEN MOVING
24850 8 IF(JA.EQ.55)RETURN
24900 RJB=.00001
25000 JA=0
25400 K=RVX1
25600 857 GO TO (1,2,3,4,2),K
25700 4 RVX2=-RVX2
25800 CC3 IF(JJA.EQ.3.OR.JJA.EQ.7.OR.JJA.EQ.10.OR.JJA.EQ.18)GO TO 12
25810 3 IF(JJA.EQ.7.OR.JJA.EQ.10.OR.JJA.EQ.18)GO TO 12
25855 C SKIP OVER CLEFS (JJA=3) IS NOW REMOVED. 6/73
25900 RJJ2=RJJ2+RVX2
26000 C MOVES UP OR DOWN
26100 IF(JJA.NE.4.AND.JJA.NE.8.AND.JJA.NE.9)GO TO 856
26360 C I THINK RJB MUST BE NON-ZERO TO WORK IN EDIT MODE?
26370 12 IF(RJJ(3).EQ.50)GO TO 856
26375 C 50=CRESC.-DECRESC.
26400 K=3
26500 IF(JJA.EQ.7.OR.JJA.EQ.18)K=4
26600 RJJ(K)=RJJ(K)+RVX2
26700 C MOVES 2ND PARVX2M UP OR DOWN
26800 GO TO 856
26900 1 RVX2=-RVX2
27000 2 RJB=RVX2
27010 856 IF(RVX4.EQ.0)GO TO 858
27020 K=RVX3
27030 RVX2=RVX4
27040 RVX4=0
27050 GO TO 857
27060 858 IF(RJB.EQ..00001)GO TO 7515
27100 IF(JJA.EQ.20.OR.JJA.EQ.9.OR.JJA.EQ.8)GO TO 5515
27110 IF(JJA.NE.4.OR.RJJ(4).EQ.0)GO TO 7515
27120 C ABOVE FOR P1=9 (BEAMS, SLURS, LINES)
27130 5515 RJJ(4)=RJJ(4)+RJB
27150 IF(RJJ(7).NE.0)RJJ(7)=RJJ(7)+RJB
27170 C RJJ(7) IS LOC. OF INNER NOTE IN BEAM RANGE.
27180 7515 RJB=RJB+RJJB
27300 END